home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / lap.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  16.7 KB  |  502 lines
  1. ;;;-*-Mode: LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27.  
  28. (in-package 'pcl)
  29.  
  30. ;;;
  31. ;;; This file defines PCL's interface to the LAP mechanism.
  32. ;;;
  33. ;;; The file is divided into two parts.  The first part defines the interface
  34. ;;; used by PCL to create abstract LAP code vectors.  PCL never creates lists
  35. ;;; that represent LAP code directly, it always calls this mechanism to do so.
  36. ;;; This provides a layer of error checking on the LAP code before it gets to
  37. ;;; the implementation-specific assembler.  Note that this error checking is
  38. ;;; syntactic only, but even so is useful to have.  Because of it, no specific
  39. ;;; LAP assembler should worry itself with checking the syntax of the LAP code.
  40. ;;;
  41. ;;; The second part of the file defines the LAP assemblers for each PCL port.
  42. ;;; These are included together in the same file to make it easier to change
  43. ;;; them all should some random change be made in the LAP mechanism.
  44. ;;;
  45.  
  46. (defvar *make-lap-closure-generator*)
  47. (defvar *precompile-lap-closure-generator*)
  48. (defvar *lap-in-lisp*)
  49.  
  50. (defun make-lap-closure-generator 
  51.     (closure-variables arguments iregs vregs fvregs tregs lap-code)
  52.   (funcall-function *make-lap-closure-generator*
  53.                 closure-variables arguments iregs 
  54.                 vregs fvregs tregs lap-code))
  55.  
  56. (defmacro precompile-lap-closure-generator 
  57.     (cvars args i-regs v-regs fv-regs t-regs lap)
  58.   (funcall-function *precompile-lap-closure-generator*
  59.                     cvars args i-regs 
  60.                 v-regs fv-regs t-regs lap))
  61.  
  62. (defmacro lap-in-lisp (cvars args iregs vregs fvregs tregs lap)
  63.   (declare (ignore cvars args))
  64.   `(locally (declare #.*optimize-speed*)
  65.      ,(make-lap-prog iregs vregs fvregs tregs
  66.              (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))))
  67.  
  68.  
  69. ;;;
  70. ;;; The following functions and macros are used by PCL when generating LAP
  71. ;;; code:
  72. ;;;
  73. ;;;  GENERATING-LAP
  74. ;;;  WITH-LAP-REGISTERS
  75. ;;;  ALLOCATE-REGISTER
  76. ;;;  DEALLOCATE-REGISTER
  77. ;;;  LAP-FLATTEN
  78. ;;;  OPCODE
  79. ;;;  OPERAND
  80. ;;; 
  81. (proclaim '(special *generating-lap*))        ;CAR   - alist of free registers
  82.                         ;CADR  - alist of allocated registers
  83.                         ;CADDR - max reg number allocated
  84.                         ;
  85.                         ;in each alist, the entries have
  86.                         ;the form:  (type . (:REG <n>))
  87.                         ;
  88.  
  89. ;;;
  90. ;;; This goes around the generation of any lap code.  <body> should return a lap
  91. ;;; code sequence, this macro will take care of converting that to a lap closure
  92. ;;; generator.
  93. ;;; 
  94. (defmacro generating-lap (closure-variables arguments &body body)
  95.   `(let* ((*generating-lap* (list () () -1)))
  96.      (finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
  97.  
  98. (defmacro generating-lap-in-lisp (closure-variables arguments &body body)
  99.   `(let* ((*generating-lap* (list () () -1)))
  100.      (finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
  101.  
  102. ;;;
  103. ;;; Each register specification looks like:
  104. ;;;
  105. ;;;  (<var> <type> &key :reuse <other-reg>)
  106. ;;;  
  107. (defmacro with-lap-registers (register-specifications &body body)
  108.   ;;
  109.   ;; Given that, for now, there is only one keyword argument and
  110.   ;; that, for now, we do no error checking, we can be pretty
  111.   ;; sleazy about how this works.
  112.   ;;
  113.   (flet ((make-allocations ()
  114.        (gathering1 (collecting)
  115.          (dolist (spec register-specifications)
  116.            (gather1
  117.          `(,(car spec) (or ,(cadddr spec) (allocate-register ',(cadr spec))))))))
  118.      (make-deallocations ()
  119.        (gathering1 (collecting)
  120.          (dolist (spec register-specifications)
  121.            (gather1
  122.          `(unless ,(cadddr spec) (deallocate-register ,(car spec))))))))
  123.     `(let ,(make-allocations)
  124.        (multiple-value-prog1 (progn ,@body)
  125.                  ,@(make-deallocations)))))
  126.  
  127. (defun allocate-register (type)
  128.   (destructuring-bind (free allocated) *generating-lap*
  129.     (let ((entry (assoc type free)))
  130.       (cond (entry
  131.          (setf (car *generating-lap*)  (delete entry free)
  132.            (cadr *generating-lap*) (cons entry allocated))
  133.          (cdr entry))
  134.         (t
  135.          (let ((new `(,type . (:reg ,(incf (the fixnum (caddr *generating-lap*)))))))
  136.            (setf (cadr *generating-lap*) (cons new allocated))
  137.            (cdr new)))))))
  138.  
  139. (defun deallocate-register (reg)
  140.   (let ((entry (rassoc reg (cadr *generating-lap*))))
  141.     (unless entry (error "Attempt to free an unallocated register."))
  142.     (push entry (car *generating-lap*))
  143.     (setf (cadr *generating-lap*) (delete entry (cadr *generating-lap*)))))
  144.  
  145. (defvar *precompiling-lap* nil)
  146.  
  147. (defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
  148.   (when (cadr *generating-lap*) (error "Registers still allocated when lap being finalized."))
  149.   (let ((iregs ())
  150.     (vregs ())
  151.     (fvregs ())
  152.     (tregs ()))
  153.     (dolist (entry (car *generating-lap*))
  154.       (ecase (car entry)
  155.     (index  (push (caddr entry) iregs))
  156.     (vector (push (caddr entry) vregs))
  157.     (fixnum-vector (push (caddr entry) fvregs))
  158.     ((t)    (push (caddr entry) tregs))))
  159.     (cond (in-lisp-p
  160.        `(lap-in-lisp ,closure-variables ,arguments ,iregs 
  161.                      ,vregs ,fvregs ,tregs ,lap-code))
  162.       (*precompiling-lap*
  163.        (values closure-variables arguments iregs 
  164.            vregs fvregs tregs lap-code))
  165.       (t
  166.        (make-lap-closure-generator
  167.          closure-variables arguments iregs 
  168.          vregs fvregs tregs lap-code)))))
  169.  
  170. (defun flatten-lap (&rest opcodes-or-sequences)
  171.   (let ((result ()))
  172.     (dolist (opcode-or-sequence opcodes-or-sequences result)
  173.       (cond ((null opcode-or-sequence))
  174.             ((not (consp (car opcode-or-sequence)))     ;its an opcode
  175.              (setf result (append result (list opcode-or-sequence))))
  176.             (t
  177.              (setf result (append result opcode-or-sequence)))))))
  178.  
  179. (defmacro flattening-lap ()
  180.   '(let ((result ()))
  181.     (values #'(lambda (value) (push value result))
  182.      #'(lambda () (apply #'flatten-lap (reverse result))))))
  183.  
  184.  
  185.  
  186. ;;;
  187. ;;; This code deals with the syntax of the individual opcodes and operands.
  188. ;;; 
  189.   
  190. ;;;
  191. ;;; The first two of these variables are documented to all ports.  They are
  192. ;;; lists of the symbols which name the lap opcodes and operands.  They can
  193. ;;; be useful to determine whether a port has implemented all the required
  194. ;;; opcodes and operands.
  195. ;;;
  196. ;;; The third of these variables is for use of the emitter only.
  197. ;;; 
  198. (defvar *lap-operands* ())
  199. (defvar *lap-opcodes*  ())
  200. (defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
  201.  
  202. (defun opcode (name &rest args)
  203.   (let ((emitter (gethash name *lap-emitters*)))
  204.     (if emitter
  205.     (apply-function (symbol-function emitter) args)
  206.     (error "No opcode named ~S." name))))
  207.  
  208. (defun operand (name &rest args)
  209.   (let ((emitter (gethash name *lap-emitters*)))
  210.     (if emitter
  211.     (apply-function (symbol-function emitter) args)
  212.     (error "No operand named ~S." name))))
  213.  
  214. (defmacro defopcode (name types)
  215.   (let ((fn-name (symbol-append "LAP Opcode " name *the-pcl-package*))
  216.     (lambda-list
  217.       (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
  218.     `(progn
  219.        (eval-when (load eval) (load-defopcode ',name ',fn-name))
  220.        (defun ,fn-name ,lambda-list
  221.      #+Genera (declare (sys:function-parent ,name defopcode))
  222.      (defopcode-1 ',name ',types ,@lambda-list)))))
  223.  
  224. (defmacro defoperand (name types)
  225.   (let ((fn-name (symbol-append "LAP Operand " name *the-pcl-package*))
  226.     (lambda-list
  227.       (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) types)))
  228.     `(progn
  229.        (eval-when (load eval) (load-defoperand ',name ',fn-name))
  230.        (defun ,fn-name ,lambda-list
  231.      #+Genera (declare (sys:function-parent ,name defoperand))
  232.      (defoperand-1 ',name ',types ,@lambda-list)))))
  233.  
  234. (defun load-defopcode (name fn-name)
  235.   (if* (memq name *lap-operands*)
  236.        (error "LAP opcodes and operands must have disjoint names.")
  237.        (setf (gethash name *lap-emitters*) fn-name)
  238.        (pushnew name *lap-opcodes*)))
  239.  
  240. (defun load-defoperand (name fn-name)
  241.   (if* (memq name *lap-opcodes*)
  242.        (error "LAP opcodes and operands must have disjoint names.")
  243.        (setf (gethash name *lap-emitters*) fn-name)
  244.        (pushnew name *lap-operands*)))
  245.  
  246. (defun defopcode-1 (name operand-types &rest args)
  247.   (iterate ((arg (list-elements args))
  248.         (type (list-elements operand-types)))
  249.     (check-opcode-arg name arg type))
  250.   (cons name (copy-list args)))
  251.  
  252. (defun defoperand-1 (name operand-types &rest args)
  253.   (iterate ((arg (list-elements args))
  254.         (type (list-elements operand-types)))
  255.     (check-operand-arg name arg type))
  256.   (cons name (copy-list args)))
  257.  
  258. (defun check-opcode-arg (name arg type)
  259.   (labels ((usual (x)
  260.          (and (consp arg) (eq (car arg) x)))
  261.        (check (x)
  262.          (ecase x           
  263.            ((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
  264.            (:label (symbolp arg))
  265.            (:operand (and (consp arg) (memq (car arg) *lap-operands*))))))
  266.     (unless (if (consp type)
  267.         (if (eq (car type) 'or)
  268.             (some #'check (cdr type))
  269.             (error "What type is this?"))
  270.         (check type))
  271.       (error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
  272.  
  273. (defun check-operand-arg (name arg type)  
  274.   (flet ((check (x)
  275.        (ecase x
  276.          (:symbol           (symbolp arg))
  277.          (:register-number  (and (integerp arg) (>= (the fixnum arg) 0)))
  278.          (:t                t)
  279.          (:reg              (and (consp arg) (eq (car arg) :reg)))
  280.          (:fixnum           (typep arg 'fixnum)))))
  281.     (unless (if (consp type)
  282.         (if (eq (car type) 'or)
  283.             (some #'check (cdr type))
  284.             (error "What type is this?"))
  285.         (check type))
  286.       (error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
  287.  
  288.  
  289.  
  290. ;;;
  291. ;;; The actual opcodes.
  292. ;;;
  293. (defopcode :break ())                ;For debugging only.  Not
  294. (defopcode :beep  ())                ;all ports are required to
  295. (defopcode :print (:reg))            ;implement this.
  296.  
  297.  
  298. (defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
  299.  
  300. (defopcode :eq     ((or :reg :constant) (or :reg :constant) :label))
  301. (defopcode :neq    ((or :reg :constant) (or :reg :constant) :label))
  302. (defopcode :fix=   ((or :reg :constant) (or :reg :constant) :label))
  303. (defopcode :izerop (:reg :label))
  304.  
  305. (defopcode :std-instance-p       (:reg :label))
  306. (defopcode :fsc-instance-p       (:reg :label))
  307. (defopcode :built-in-instance-p  (:reg :label))
  308. (defopcode :structure-instance-p (:reg :label))
  309. #+pcl-user-instances
  310. (defopcode :user-instance-p      (:reg :label))
  311.  
  312. (defopcode :jmp      ((or :reg :constant)))
  313.  
  314. (defopcode :label  (:label))
  315. (defopcode :go     (:label))
  316.  
  317. (defopcode :return ((or :reg :constant)))
  318.  
  319. (defopcode :exit-lap-in-lisp ())
  320.  
  321. ;;;
  322. ;;; The actual operands.
  323. ;;;
  324. (defoperand :reg  (:register-number))
  325. (defoperand :cvar (:symbol))
  326. (defoperand :arg  (:symbol))
  327.  
  328. (defoperand :cdr  (:reg))
  329.  
  330. (defoperand :constant (:t))
  331.  
  332. (defoperand :std-wrapper       (:reg))
  333. (defoperand :fsc-wrapper       (:reg))
  334. (defoperand :built-in-wrapper  (:reg))
  335. (defoperand :structure-wrapper (:reg))
  336. (defoperand :other-wrapper     (:reg))
  337. (defoperand :built-in-or-structure-wrapper (:reg))
  338. #+pcl-user-instances
  339. (defoperand :user-wrapper      (:reg))
  340.  
  341. (defoperand :std-slots (:reg))
  342. (defoperand :fsc-slots (:reg))
  343. #+pcl-user-instances
  344. (defoperand :user-slots (:reg))
  345.  
  346. (defoperand :wrapper-cache-number-vector (:reg))
  347.  
  348. (defoperand :cref (:reg :fixnum))
  349.  
  350. (defoperand :iref (:reg :reg))
  351. (defoperand :iset (:reg :reg :reg))
  352.  
  353. (defoperand :i1+     (:reg))
  354. (defoperand :i+      (:reg :reg))
  355. (defoperand :i-      (:reg :reg))
  356. (defoperand :ilogand (:reg :reg))
  357. (defoperand :ilogxor (:reg :reg))
  358. (defoperand :ishift  (:reg :fixnum))
  359.  
  360. (defoperand :lisp (:t))
  361. (defoperand :lisp-variable (:symbol))
  362.  
  363.  
  364.  
  365. ;;;
  366. ;;; LAP tests (there need to be a lot more of these)
  367. ;;;
  368. #|
  369. (defun make-lap-test-closure-1 (result)
  370.   #'(lambda (arg1)
  371.       (declare (pcl-fast-call))
  372.       (declare (ignore arg1))
  373.       result))
  374.  
  375. (defun make-lap-test-closure-2 (result)
  376.   #'(lambda (arg1 arg2)
  377.       (declare (pcl-fast-call))
  378.       (declare (ignore arg1 arg2))
  379.       result))
  380.  
  381. (eval-when (eval)
  382.   (compile 'make-lap-test-closure-1)
  383.   (compile 'make-lap-test-closure-2))
  384.  
  385. (proclaim '(special lap-win lap-lose))
  386. (eval-when (load eval)
  387.   (setq lap-win (make-lap-test-closure-1 'win)
  388.     lap-lose (make-lap-test-closure-1 'lose)))
  389.  
  390. (defun lap-test-1 ()
  391.   (let* ((cg (generating-lap '(cache)
  392.                  '(arg)
  393.            (with-lap-registers ((i0 index)
  394.                     (v0 vector)
  395.                     (t0 t))
  396.          (flatten-lap 
  397.            (opcode :move (operand :cvar 'cache) v0)
  398.            (opcode :move (operand :arg 'arg) i0)
  399.            (opcode :move (operand :iref v0 i0) t0)
  400.            (opcode :jmp t0)))))
  401.      
  402.      (cache (make-array 32))
  403.      (closure (funcall cg cache))
  404.      (fn0 (make-lap-test-closure-1 'fn0))
  405.      (fn1 (make-lap-test-closure-1 'fn1))
  406.      (fn2 (make-lap-test-closure-1 'fn2))
  407.      (in0 (index-value->index 2))
  408.      (in1 (index-value->index 10))
  409.      (in2 (index-value->index 27)))
  410.     
  411.     (setf (svref cache (index->index-value in0)) fn0
  412.       (svref cache (index->index-value in1)) fn1
  413.       (svref cache (index->index-value in2)) fn2)
  414.     
  415.     (unless (and (eq (funcall closure in0) 'fn0)
  416.          (eq (funcall closure in1) 'fn1)
  417.          (eq (funcall closure in2) 'fn2))
  418.       (error "LAP TEST 1 failed."))))
  419.  
  420. (defun lap-test-2 ()            
  421.   (let* ((cg (generating-lap '(cache mask) 
  422.                  '(arg)
  423.            (with-lap-registers ((i0 index)
  424.                     (i1 index)
  425.                     (i2 index)
  426.                     (v0 vector)
  427.                     (t0 t))
  428.  
  429.          (flatten-lap          
  430.            (opcode :move (operand :cvar 'cache) v0)
  431.            (opcode :move (operand :arg 'arg) i0)
  432.            (opcode :move (operand :cvar 'mask) i1)
  433.            (opcode :move (operand :ilogand i0 i1) i2)
  434.            (opcode :move (operand :iref v0 i2) t0)
  435.            (opcode :jmp t0)))))
  436.      (cache (make-array 32))
  437.      (mask #b00110)
  438.      (closure (funcall cg cache mask))
  439.      (in0 (index-value->index #b00010))
  440.      (in1 (index-value->index #b01010))
  441.      (in2 (index-value->index #b10011)))
  442.     (fill cache lap-lose)
  443.     (setf (svref cache (index->index-value in0)) lap-win)
  444.     
  445.     (unless (and (eq (funcall closure in0) 'win)
  446.          (eq (funcall closure in1) 'win)
  447.          (eq (funcall closure in2) 'win))
  448.       (error "LAP TEST 2 failed."))))
  449.  
  450. (defun lap-test-3 ()            
  451.   (let* ((cg (generating-lap '(addend) '(arg)
  452.            (with-lap-registers
  453.          ((i0 index)
  454.           (i1 index)
  455.           (i2 index))
  456.  
  457.          (flatten-lap          
  458.            (opcode :move (operand :cvar 'addend) i0)
  459.            (opcode :move (operand :arg 'arg) i1)
  460.            (opcode :move (operand :i+ i0 i1) i2)
  461.            (opcode :return i2)))))
  462.      (closure (funcall cg (index-value->index 5))))
  463.     
  464.     (unless (= (index->index-value (funcall closure (index-value->index 2))) 7)
  465.       (error "LAP TEST 3 failed."))))
  466.  
  467. (defun lap-test-4 ()            
  468.   (let* ((cg (generating-lap '(winner loser) '(arg)
  469.            (with-lap-registers ((t0 t))
  470.          (flatten-lap
  471.            (opcode :move (operand :arg 'arg) t0)
  472.            (opcode :eq t0 (operand :constant 'foo) 'win)
  473.            (opcode :move (operand :cvar 'loser) t0)
  474.            (opcode :jmp t0)
  475.            (opcode :label 'win)
  476.            (opcode :move (operand :cvar 'winner) t0)
  477.            (opcode :jmp t0)))))
  478.      (closure (funcall cg #'true #'false)))
  479.     (unless (and (eq (funcall closure 'foo) 't)
  480.          (eq (funcall closure 'bar) 'nil))
  481.       (error "LAP TEST 4 failed."))))
  482.  
  483. (defun lap-test-5 ()            
  484.   (let* ((cg (generating-lap '(array) '(arg)
  485.            (with-lap-registers ((r0 vector)
  486.                     (r1 t)
  487.                     (r2 index))
  488.          (flatten-lap
  489.            (opcode :move (operand :cvar 'array) r0)
  490.            (opcode :move (operand :arg 'arg) r1)
  491.            (opcode :move (operand :constant (index-value->index 0)) r2)
  492.            (opcode :move r1 (operand :iref r0 r2))
  493.            (opcode :return r1)))))
  494.      (array (make-array 1))
  495.      (closure (funcall cg array)))
  496.     (unless (and (=  (funcall closure 1)    (svref array 0))
  497.          (eq (funcall closure 'foo) (svref array 0)))
  498.       (error "LAP TEST 5 failed."))))
  499.  
  500. |#
  501.  
  502.